perm filename BEAMX.F4[NEW,LCS]2 blob
sn#353892 filedate 1978-05-07 generic text, type T, neo UTF8
SUBROUTINE BEAMX
COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20) /RRJJ/RJJ2,RJJ(20)
1 /LIMIT/LIMIT,ITEM,L,I,IX /STF/RSTFAC(0/7),RSTJ2
EQUIVALENCE (J3,JQ(1)),(J4,JQ(2)),(J5,JQ(3)),(R5,RJQ(3)),
1 (R6,RJQ(4)),(J10,JQ(8)),(J6,JQ(4)),(R4,RJQ(2)),(R7,RJQ(5))
1,(R3,RJQ(1)),(J8,JQ(6)),(J7,JQ(5))
1,(R11,RJQ(9)),(R10,RJQ(8)),(R8,RJQ(6)),(RJ3,RJJ(1))
1,(R9,RJQ(7)),(J9,JQ(7))
IF(J10.GE.100)GO TO 6
CALL BMSTF
RETURN
6 JZ=-2
JX8=R8
IF(JX8.GE.-1)GO TO 16
JX8=R8/10.0
JX8=JX8*10
C MAKE SURE LAST DIGIT IS ZERO
R8=JX8
16 RR8=R8
R8=0
RR9=R9
R9=0
CC RR10=R10
RR6=R6
RR3=R3
RR4=R4
RR5=R5
RSTJ=RSTJ2
J=10*(J7/10)
C J=STEM DIR. (10 OR 20)
JJ=J10/100
JJ10=J10-JJ*100
C IF 3RD DIGIT OF P10 = 0, THEN TWO SECONDARY BEAM GROUPS ARE MADE.
C THEN P8 AND P9 ARE THE LIMITS OF THE GAP BETWEEN THE SECONDARY GROUPS.
C IF 3RD DIGIT OF P10 = 1, THEN SINGLE SECONDARY BEAM GROUP IS MADE.
C THEN P8 AND P9 ARE THE OUTER LIMITS OF THE SECONDARY GROUP
CCC JJ7=J7-JJ
CCC J7=J+JJ
JJ7=J7-J
C J7=NUM. OF FULL BEAMS (1ST DIGIT OF P10=NUM OF ADDED BEAMS)
7 J10=0
5 J8=R8
J9=R9
R7=J7
R10=J10
CALL BMSTF
JZ=JZ+1
IF(JZ)1,2,3
3 RETURN
1 IF(RR8.GE.0)GO TO 8
IF(JX8.GE.-20)GO TO 11
C UNATTACHED PARTIAL BEAM:
C P8= -10=ON LEFT, -20=RIGHT, -30=BOTH
RR8=RR8+10
IF(JX8.EQ.-31)GO TO 11
JX8=JX8-1
RR9=0
C ↑↑↑ A PRECAUTION
JZ=JZ-2
11 R8=RR8-AMOD(R7,10.0)
CC J7=J+JJ
10 R9=RR9
JZ=JZ+1
GO TO 4
8 IF(JJ10.EQ.0)GO TO 9
C NEXT MAKES ONE SECONDARY BEAM GROUP.
R8=RR8
GO TO 10
9 R8=-1
R9=RR8
4 J7=J+JJ
CCC4 J7=JJ7
R6=RR6
R3=RR3
J3=RR3
R4=RR4
R5=RR5
J10=JJ7
CCC J10=JJ
C J10 IS DISPLACEMENT FOR OTHER BEAMS
RSTJ2=RSTJ
GO TO 5
2 R8=RR9
R9=-1
GO TO 4
END